perm filename EXPR.SAI[PNT,HE]32 blob
sn#576950 filedate 1981-04-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00005 00003 ! isnil_,equ_,check_,mult_,divide_ dimens, dimerr
C00010 00004 ! miscellaneous definitions
C00016 00005 ! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor
C00024 00006 ! expression builders: hash,hashindex,new_expr,check_expr,!!expr1,!!expr2,!!expr3
C00027 00007 ! expression builders: opcode, idcode, cncode,incode,arcode,prcode
C00045 00008 ! strcode,vmcode,isaffixedcode,armreachcode
C00052 00009 ! mkexpr,gtexpr,aref,idref,pref
C00057 00010 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00059 00011 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off
C00065 00012 ! $append,$aappend
C00069 00013 ! $$gtidref,$$gtanyexp,$$gtexpr,$$gtvexpr
C00072 00014 ! $$gtxp2
C00073 00015 END "EXPR"
C00074 ENDMK
C⊗;
ENTRY;
BEGIN "EXPR"
DEFINE $$PRGID=TRUE; DEFINE $EXPR=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
REQUIRE "[][]" DELIMITERS;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
REAL PROCEDURE SIMPLIFY(INTEGER OP;REAL F1,F2);
BEGIN "simplifies binary operations on scalar constants "
INTEGER I1,I2,B1,B2; REAL F3;
I1←F1; I2←F2;
B1←IF F1 THEN 1 ELSE 0;
B2←IF F2 THEN 1 ELSE 0;
CASE OP OF
BEGIN
REDEFINE ZZ(ARG0,ARG1,ARG2,EX)=[;];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[;EX];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[];
OP_LIST
END;
RETURN(F3);
END;
REDEFINE ZZ(ACR0,ARG1,ARG2,EX)=[FALSE,];
REDEFINE ZZC(ARG0,ARG1,ARG2,EX)=[TRUE,];
preload_array(COMPILEEXPRESSION, OP_LIST,BOOLEAN, 1, #PNTINTOPS);
! will be moved to SYMBOL;
RPTR(EXPR$)PROCEDURE MK_EXPR$;
BEGIN
RPTR(EXPR$)EE;
EE←NEW_RECORD(EXPR$);
if !debug and ¬!!debugging then EXPR$:DBEXPR[ee]←NEW_RECORD(DBEXPR);
RETURN(EE);
END;
BOOLEAN RETURN_NULL;
! isnil_,equ_,check_,mult_,divide_ dimens, dimerr ;
INTERNAL BOOLEAN PROCEDURE isnil_dimens(RPTR(DIMENS)D1);
IF D1=NIL_DIMENS OR D1=NULL_RECORD THEN RETURN(TRUE)
ELSE
RETURN( (DIMENS:TIME[D1]=0)
AND (DIMENS:DISTANCE[D1]=0)
AND (DIMENS:FORCE[D1]=0)
AND (DIMENS:ANGLE[D1]=0));
INTERNAL BOOLEAN PROCEDURE equ_dimens(RPTR(DIMENS)D1,D2);
BEGIN
IF D1=NULL_RECORD THEN D1←NIL_DIMENS;
IF D2=NULL_RECORD THEN D2←NIL_DIMENS;
RETURN( (DIMENS:TIME[D1]=DIMENS:TIME[D2])
AND (DIMENS:DISTANCE[D1]=DIMENS:DISTANCE[D2])
AND (DIMENS:FORCE[D1]=DIMENS:FORCE[D2])
AND (DIMENS:ANGLE[D1]=DIMENS:ANGLE[D2]));
END;
INTERNAL BOOLEAN PROCEDURE check_dimens(RPTR(DIMENS)D1,D2);
BEGIN
IF NON_STRICT_DIMENSIONAL_CHECKING THEN
IF ISNIL_DIMENS(D1) OR ISNIL_DIMENS(D2) THEN RETURN(TRUE);
RETURN(EQU_DIMENS(D1,D2));
END;
INTERNAL RPTR(DIMENS)PROCEDURE mult_dimens(RPTR(DIMENS)D1,D2);
BEGIN RPTR(DIMENS)R1; R1←NEW_RECORD(DIMENS);
IF D1=NULL_RECORD THEN D1←NIL_DIMENS;
IF D2=NULL_RECORD THEN D2←NIL_DIMENS;
DIMENS:FORCE[R1]←DIMENS:FORCE[D1]+DIMENS:FORCE[D2];
DIMENS:DISTANCE[R1]←DIMENS:DISTANCE[D1]+DIMENS:DISTANCE[D2];
DIMENS:TIME[R1]←DIMENS:TIME[D1]+DIMENS:TIME[D2];
DIMENS:ANGLE[R1]←DIMENS:ANGLE[D1]+DIMENS:ANGLE[D2];
RETURN(R1);
END;
RPTR(DIMENS)PROCEDURE sqrt_dimens(RPTR(DIMENS)D1);
BEGIN RPTR(DIMENS)R1; R1←NEW_RECORD(DIMENS);
IF D1=NULL_RECORD THEN D1←NIL_DIMENS;
DIMENS:FORCE[R1]←DIMENS:FORCE[D1]/2;
DIMENS:DISTANCE[R1]←DIMENS:DISTANCE[D1]/2;
DIMENS:TIME[R1]←DIMENS:TIME[D1]/2;
DIMENS:ANGLE[R1]←DIMENS:ANGLE[D1]/2;
RETURN(R1);
END;
INTERNAL RPTR(DIMENS)PROCEDURE divide_dimens(RPTR(DIMENS)D1,D2);
BEGIN RPTR(DIMENS)R1; R1←NEW_RECORD(DIMENS);
IF D1=NULL_RECORD THEN D1←NIL_DIMENS;
IF D2=NULL_RECORD THEN D2←NIL_DIMENS;
DIMENS:FORCE[R1]←DIMENS:FORCE[D1]-DIMENS:FORCE[D2];
DIMENS:DISTANCE[R1]←DIMENS:DISTANCE[D1]-DIMENS:DISTANCE[D2];
DIMENS:TIME[R1]←DIMENS:TIME[D1]-DIMENS:TIME[D2];
DIMENS:ANGLE[R1]←DIMENS:ANGLE[D1]-DIMENS:ANGLE[D2];
RETURN(R1);
END;
INTERNAL RPTR(DIMENS)PROCEDURE inverse_dimens(RPTR(DIMENS)D1);
RETURN(divide_dimens(NIL_DIMENS,D1));
STRING PROCEDURE STRINGIFY(RPTR(DIMENS)D1);
BEGIN
STRING S; INTEGER I;
IF EQU_DIMENS(D1,NIL_DIMENS) THEN RETURN("DIMENSIONLESS");
S←NULL;
IF I←DIMENS:DISTANCE[D1] THEN S←S&"*[DISTANCE]↑"&CVS(I)&" ";
IF I←DIMENS:TIME[D1] THEN S←S&"*[TIME]↑"&CVS(I)&" ";
IF I←DIMENS:FORCE[D1] THEN S←S&"*[FORCE]↑"&CVS(I)&" ";
IF I←DIMENS:ANGLE[D1] THEN S←S&"*[ANGLE]↑"&CVS(I)&" ";
RETURN(S[2 TO ∞-1])
END;
INTERNAL STRING PROCEDURE DIMERR(STRING S1; RPTR(DIMENS)D1;
STRING S2; RPTR(DIMENS)D2);
BEGIN
STRING S; INTEGER I;
S←CRLF&S1&" has dimensions: "&STRINGIFY(D1)&CRLF&S2&" has dimensions: "
&STRINGIFY(D2);
RETURN(S);
END;
INTERNAL PROCEDURE CHKDIMERR(STRING ST,S1; RPTR(DIMENS)D1;
STRING S2; RPTR(DIMENS)D2);
IF NOT EQU_DIMENS(D1,D2) THEN
WARN("Dimensional incompatibility in "&ST&DIMERR(S1,D1,S2,D2));
! miscellaneous definitions ;
PRELOAD_WITH "SCALAR","VECTOR","ROT","TRANS","FRAME","EVENT","STRING";
STRING ARRAY DTYPES[1:7];
COMMENT TEMPORARY EXPR RECORD USED INTERNALLY BY THESE ROUTINES;
RCLASS !!EXPR(INTEGER OP,X1,X2; INTEGER TYPE,#EL; RPTR(!!EXPR)SON,BRO;
BOOLEAN CONST; REAL RLVAL; RPTR(EXPR$)EXPR$; RPTR(DIMENS)DIMENS);
! OP is opcode, x1,x2 are used to represent floating point numbers in 11 format
x1 along is used for index of array
x2 is used for leveloffset of array
const is true if the value is a constant
expr$ is used (particularly in QUERY) to store record EXPR$;
INTEGER ##EL;
INTEGER BRCHAR,SPBR;
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,] ;
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG0,] ;
preload_array(CODE_OP, OP_LIST,STRING, 1, #PNTINTOPS);
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
REDEFINE ZZC(ARG0,ARG1,ARG2)=[ARG2,];
preload_array(CODE_LEVEL,OP_LIST,INTEGER,1,#PNTINTOPS);
REDEFINE XXCOUNT=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[
REDEFINE XXCOUNT=XXCOUNT + 1;];
OP_LIST;
DEFINE XXARG=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE ZZC(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,DIMR,DIM1,DIM2,DIM3)=[
REDEFINE XXVAL = ((((XXARG*#DTYPE)+ARG1)*#DTYPE+ARG2)*#DTYPE+ARG3);
XXVAL,
];
DEFINE #HASHTAB=XXCOUNT;
preload_array(HASHTAB, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,AR2,ARG,
DIMR,DIM1,DIM2,DIM3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
REQUIRE "UNDEFINED OP:: "&CVPS(ARGNAME)&"
" MESSAGE;
ENDC];
OP_LIST;
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
MAKEOP(ARGNAME)
ENDC ARGNAME,];
preload_array(PCODE, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[ARGNDX,];
preload_array(PCODENDX, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[ARGTYPE,];
preload_array(OPTYPE, OP_LIST, INTEGER, 1, #HASHTAB);
DEFINE #DDTYPE=100;
REDEFINE XXX(ARGNAME,ARDNDX,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3,
DIMR,DIM1,DIM2,DIM3)=[
REDEFINE XXFOO = ((((DIMR*#DDTYPE)+DIM1)*#DDTYPE+DIM2)*#DDTYPE+DIM3);
XXFOO,
];
preload_array(DIMDATA, OP_LIST, INTEGER, 1, #HASHTAB);
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α INTEGER I;
GTOKEN(FLAG);
FOR I←1 STEP 1 UNTIL #PNTINTOPS
DO IF EQU(TOKEN,CODE_OP[I])
THEN BEGIN
#TOKEN←OPERATOR_TYPE;
TOKEN_CLASS←CODE_LEVEL[I];
TOKEN_INDEX←I;
RETURN;
END;
IF EQU(TOKEN,0) THEN #TOKEN←UNDECLARED_TYPE;
β;
FORWARD RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
FORWARD RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
FORWARD RPTR (!!EXPR) PROCEDURE INCODE(INTEGER VAL);
FORWARD RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
FORWARD RECURSIVE RPTR (!!EXPR) PROCEDURE ARCODE(RPTR(SYMBOL)PTR;INTEGER OPERATION(XGTVAL));
FORWARD RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
FORWARD RPTR(!!EXPR)PROCEDURE STRCODE(STRING S; INTEGER FIRSTNUM(XPUSHQI));
FORWARD RPTR (!!EXPR) PROCEDURE VMCODE;
FORWARD RPTR (!!EXPR) PROCEDURE ISAFFIXEDCODE;
FORWARD RPTR (!!EXPR) PROCEDURE ARMREACHCODE;
! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor;
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} WR {+|- WR }
WRT/REL WR: T WRT T
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP= [XXXXX(EXP_XX)];
! FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE PF XXXXX(PF_XX);
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
RECURSIVE RPTR(!!EXPR) PROCEDURE OP1(INTEGER LVL);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
RETURN(OPCODE(I,1,XXXXX(LVL)));
β;
RECURSIVE RPTR(!!EXPR)PROCEDURE OP2(INTEGER LVL;RPTR(!!EXPR)E);
α INTEGER I; I←TOKEN_INDEX; GGTOKEN;
!!EXPR:BRO[E]←XXXXX(LVL);
RETURN(OPCODE(I,2,E));
β;
RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(!!EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND #TOKEN=OPERATOR_TYPE
AND TOKEN_CLASS= AEXP_XX
THEN $$1←OP1(LEVEL + 1)
ELSE $$1←XXXXX(LEVEL+1);
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS=LEVEL DO
$$1←OP2(LEVEL+1,$$1);
β;
[EXP_XX] [BTERM_XX] [FACTOR_XX][WRTREL_XX]
α
$$1←XXXXX(LEVEL + 1);
IF (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS=LEVEL
THEN $$1←OP2(LEVEL+1,$$1);
β;
[PF_XX]
CASE #TOKEN OF
α "CASE #TOKEN"
[REAL_TYPE]
α INTEGER I;
$$1←CNCODE(REALSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[INT_TYPE]
α INTEGER I;
$$1←INCODE(INTSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[ID_TYPE]
α CASE SYMBOL:ACCESS[TOKENPTR] OF
α
[#SIMPLE] $$1←IDCODE(TOKENPTR);
[#ARRAY] $$1←ARCODE(TOKENPTR);
[#PROCEDURE] $$1←VPRCODE(TOKENPTR)
β;
GGTOKEN(FALSE);
β ;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α "CASE TOKEN_INDEX"
[LPAREN_X]
α "LPAREN_X"
GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←OPCODE(IMPLICIT_X,I2,$$1);
β "LPAREN_X";
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←OPCODE(MAGNITUDE_X,1,$$1);
β;
[STOS_X][DOWNARROW_X][DOLLAR_X][ALPHA_X][NOT_X]
$$1←OP1(EXP_XX);
[INSCALAR_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD);
GGTOKEN(FALSE);
β;
[ISAFFIXED_X] $$1←ISAFFIXEDCODE;
[ARMREACH_X] $$1←ARMREACHCODE;
[VM_X] IF CURPROC THEN $$1←VMCODE
ELSE ERROR("VM can only be called in a procedure body");
[QQUERY_X]
α
$$1←OPCODE(TOKEN_INDEX,0,NULL_RECORD,PRINTCODE);
GGTOKEN(FALSE);
β;
ELSE IF TOKEN=DQUOTE THEN
α "string constant found"
READTILL(dquote);
$$1←STRCODE(TOKEN);
GGTOKEN(FALSE);
β "string constant found"
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
IF I=RUNTIME_X THEN
α GGTOKEN(FALSE);
IF TOKEN≠"(" THEN RETURN($$1←OPCODE(I,1,CNCODE(0.0)))
ELSE STOKEN←TRUE;
β;
WORD_READ("(");
GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN ERROR("MISMATCHED PAREN") ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
β "CASE TOKEN_INDEX";
[RES_TYPE]
α I←TOKEN_INDEX;
IF TOKEN_CLASS=LEVEL
THEN
α WORD_READ("("); GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
ELSE IF RETURN_NULL THEN $$1←NULL_RECORD
ELSE ERROR(TOKEN&" is not a valid term in an expression");
β;
ELSE IF TOKEN=DQUOTE THEN
α "string constant found"
READTILL(dquote);
$$1←STRCODE(TOKEN);
GGTOKEN(FALSE);
β "string constant found"
ELSE
α
IF RETURN_NULL THEN $$1←NULL_RECORD
ELSE ERROR("UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃");
β
β "CASE #TOKEN"
β;
RETURN($$1);
β;
! expression builders: hash,hashindex,new_expr,check_expr,!!expr1,!!expr2,!!expr3;
INTEGER PROCEDURE HASH(INTEGER OP; INTEGER ARRAY IX);
RETURN((((OP*#DTYPE + IX[1])*#DTYPE+IX[2])*#DTYPE +IX[3]));
INTEGER PROCEDURE HASHINDEX(INTEGER HASHVAL);
BEGIN
INTEGER INDEX,LB,UB;
LB←1;UB←#HASHTAB;
DO BEGIN
INDEX←(LB+UB)/2;
IF HASHTAB[INDEX]=HASHVAL THEN RETURN(INDEX)
ELSE IF HASHTAB[INDEX]>HASHVAL THEN UB←INDEX-1
ELSE LB←INDEX+1;
END UNTIL LB>UB;
RETURN(0);
END;
RPTR (!!EXPR) PROCEDURE NEW_EXPR(INTEGER OP; RPTR(!!EXPR) SON(NULL_RECORD),
BRO(NULL_RECORD),SELF(NULL_RECORD));
BEGIN
RPTR (!!EXPR) CUR;
IF SELF=NULL_RECORD THEN CUR←NEW_RECORD(!!EXPR) ELSE CUR←SELF;
!!EXPR:OP[CUR]←OP;
!!EXPR:SON[CUR]←SON;
!!EXPR:BRO[CUR]←BRO;
##EL←##EL + (!!EXPR:#EL[CUR]←1);
RETURN(CUR);
END;
INTEGER PROCEDURE CHECK_EXPR(INTEGER OP,NARGS; RPTR(!!EXPR)ARRAY EXPRRY);
BEGIN
COMMENT EXPPRY WILL BE OF SIZE [1:NARGS];
INTEGER I;
INTEGER ARRAY IX[1:3];
IF NARGS>3 THEN ERROR("More arguments for function "&CODE_OP[OP]&" than allowed");
ARRCLR(IX);
FOR I←1 STEP 1 UNTIL NARGS DO IX[I]←!!EXPR:TYPE[EXPRRY[I]];
I←HASHINDEX(HASH(OP,IX));
RETURN(I);
END;
RPTR(!!EXPR)PROCEDURE !!EXPRM(INTEGER NARGS,OP,X1(0),X2(0));
BEGIN RPTR(!!EXPR) R1;
R1←NEW_RECORD(!!EXPR);
##EL←##EL+(!!EXPR:#EL[R1]←NARGS);
!!EXPR:OP[R1]←OP;
!!EXPR:X1[R1]←X1;
!!EXPR:X2[R1]←X2;
END;
! expression builders: opcode, idcode, cncode,incode,arcode,prcode;
RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR;
RPTR(EXPR$)EEPTR(NULL_RECORD));
BEGIN
RPTR(!!EXPR)ARRAY EXPRRY[0:NARGS]; ! 0 in case NARGS=0 ;
RPTR(DIMENS)ARRAY EXPDIM[0:NARGS];
RPTR(!!EXPR) P1,P2; RPTR(DIMENS)RESULT_DIMENS;
INTEGER ARRAY DIMENSINDEX[0:3];
INTEGER I;INTEGER PCODE_INDEX,DIMVALUE;
P1←EPTR;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
EXPRRY[I]←P1;
EXPDIM[I]←!!EXPR:DIMENS[P1];
P1←!!EXPR:BRO[P1];
END;
IF P1≠NULL_RECORD THEN ERROR("P1 should be null record");
IF (PCODE_INDEX←CHECK_EXPR(OP,NARGS,EXPRRY))=0
THEN BEGIN
STRING S; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
S←S&" "&DTYPES[!!EXPR:TYPE[EXPRRY[I]]]&",";
ERROR("operator/function "&CODE_OP[OP]&" cannot take operand(s)"&S[1 to ∞-1]);
END;
DIMVALUE←DIMDATA[PCODE_INDEX];
FOR I←3 STEP -1 UNTIL 0 DO
BEGIN
DIMENSINDEX[I]←DIMVALUE MOD #DDTYPE;
DIMVALUE←DIMVALUE DIV #DDTYPE;
END;
FOR I←1 STEP 1 UNTIL NARGS,0 DO
BEGIN
RPTR(DIMENS)CURDIM,DUMMYDIM;
STRING ERRM;
PROCEDURE FOO(RPTR(DIMENS)DD; STRING S);
BEGIN CURDIM←DD; ERRM←S; END;
DUMMYDIM←NEW_RECORD(DIMENS);
CASE DIMENSINDEX[I] OF
BEGIN
[SAME1_D] FOO(EXPDIM[1],"argument 1");
[SAME2_D] FOO(EXPDIM[2],"argument 2");
[SAME3_D] FOO(EXPDIM[3],"argument 3");
[ANY_D] FOO(EXPDIM[I],NULL);
[ANGL_D] FOO(ANGLE_DIMENS,"ANGLE");
[NIL_D] FOO(NIL_DIMENS,"CONSTANT");
[DIST_D] FOO(DISTANCE_DIMENS,"DISTANCE");
[TIME_D] FOO(TIME_DIMENS,"TIME");
[SAME12_D][SAME123_D] FOO(DUMMYDIM,NULL);
ELSE FOO(DUMMYDIM,"unexpected argument: error in system")
END;
IF I≠0 THEN
BEGIN "I≠0"
IF NOT check_dimens(EXPDIM[I],CURDIM) THEN
WARN("Argument "&CVS(I)&
" must have same dimensions as that of "&ERRM&
DIMERR("Argument "&CVS(I),EXPDIM[I],ERRM,CURDIM));
END "I≠0"
ELSE CASE DIMENSINDEX[0] OF
BEGIN
[MULT_D] RESULT_DIMENS←MULT_DIMENS(EXPDIM[1],EXPDIM[2]);
[DIVID_D]RESULT_DIMENS←DIVIDE_DIMENS(EXPDIM[1],EXPDIM[2]);
[SQRT_D] RESULT_DIMENS←SQRT_DIMENS(EXPDIM[1]);
[SAME1_D]RESULT_DIMENS←EXPDIM[1];
[SAME12_D] IF NOT EQU_DIMENS(EXPDIM[1],NIL_DIMENS)
THEN RESULT_DIMENS←EXPDIM[1]
ELSE RESULT_DIMENS←EXPDIM[2];
[SAME123_D] IF NOT EQU_DIMENS(EXPDIM[1],NIL_DIMENS)
THEN RESULT_DIMENS←EXPDIM[1]
ELSE IF NOT EQU_DIMENS(EXPDIM[2],NIL_DIMENS)
THEN RESULT_DIMENS←EXPDIM[2]
ELSE RESULT_DIMENS←EXPDIM[3];
ELSE IF CURDIM=DUMMYDIM THEN
ERROR("ERROR - should not have got here")
ELSE RESULT_DIMENS←CURDIM
END;
END;
IF NOT !NOFOLD AND COMPILEEXPRESSION[OP] THEN
BEGIN "constant folding"
IF NARGS=2 AND OPTYPE[PCODE_INDEX]=#SC AND
!!EXPR:CONST[EXPRRY[1]] AND !!EXPR:CONST[EXPRRY[2]]
THEN BEGIN "constant arguments"
REAL R;
##EL←##EL-!!EXPR:#EL[EXPRRY[1]]-!!EXPR:#EL[EXPRRY[2]];
R←SIMPLIFY(OP,!!EXPR:RLVAL[EXPRRY[1]],!!EXPR:RLVAL[EXPRRY[2]]);
P1←CNCODE(R);
RETURN(P1);
END
ELSE IF NARGS=1 AND OPTYPE[PCODE_INDEX]=#SC AND !!EXPR:CONST[EXPRRY[1]]
THEN BEGIN
REAL R;
##EL←##EL-!!EXPR:#EL[EXPRRY[1]];
R←SIMPLIFY(OP,0.0,!!EXPR:RLVAL[EXPRRY[1]]);
P1←CNCODE(R);
RETURN(P1);
END;
END;
P1←NEW_RECORD(!!EXPR);
IF PCODENDX[PCODE_INDEX]
THEN BEGIN I←2; !!EXPR:X1[P1]←PCODENDX[PCODE_INDEX]; END
ELSE I←1;
##EL←##EL + (!!EXPR:#EL[P1]←I);
!!EXPR:OP[P1]←PCODE[PCODE_INDEX];
!!EXPR:TYPE[P1]←OPTYPE[PCODE_INDEX];
!!EXPR:SON[P1]←EPTR;
IF (!!EXPR:EXPR$[P1]←EEPTR) THEN ##EL←##EL+EXPR$:#BODY[EEPTR];
!!EXPR:DIMENS[P1]←RESULT_DIMENS;
RETURN(P1);
END;
RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
BEGIN "cncode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1; INTEGER I1,I2;
FLTOUT(VAL,I1,I2);
E1←!!EXPRM(3,XPUSHSCI,I1,I2);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:CONST[E1]←TRUE;
!!EXPR:RLVAL[E1]←VAL;
!!EXPR:DIMENS[E1]←NIL_DIMENS;
RETURN(E1);
END "cncode";
RPTR (!!EXPR) PROCEDURE INCODE(INTEGER VAL);
BEGIN "incode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1;
E1←!!EXPRM(2,XPUSHINTI,VAL);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:CONST[E1]←TRUE;
!!EXPR:RLVAL[E1]←VAL;
!!EXPR:DIMENS[E1]←NIL_DIMENS;
RETURN(E1);
END "incode";
RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
BEGIN ! COMMENT CHANGE ID_OFFSET PART WHEN WE CAN DETERMINE ID_OFFSET DIRECTLY;
RPTR(!!EXPR)E1;
IF SYMBOL:INDEX[SYMPTR]>0 THEN
E1←!!EXPRM(3,XAGTVAL,SYMBOL:INDEX[SYMPTR],SYMBOL:OFFSET[SYMPTR])
ELSE
E1←!!EXPRM(2,XGTVAL,SYMBOL:OFFSET[SYMPTR]);
!!EXPR:TYPE[E1]←SYMBOL:TYPE[SYMPTR];
!!EXPR:DIMENS[E1]←SYMBOL:DIMENS[SYMPTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE IDNDXCODE(RPTR(SYMBOL)PTR);
IF SYMBOL:INDEX[PTR]>0
THEN BEGIN RPTR(!!EXPR) E1;
E1←!!EXPRM(2,XPUSHINTI,SYMBOL:INDEX[PTR]);
!!EXPR:DIMENS[E1]←SYMBOL:DIMENS[PTR];
RETURN(E1);
END
ELSE RETURN(NEW_EXPR(XNOOP));
RECURSIVE RPTR(!!EXPR)PROCEDURE ARNDXCODE(RPTR(SYMBOL)PTR);
BEGIN
! This procedure produces the tree form for the array
reference index. To get the full array reference
use arcode with the right argument GTVAL or CHNGE;
RPTR(!!EXPR)E2,E3;
INTEGER I;
GGTOKEN;
IF TOKEN≠"[" THEN ERROR("Need [ after array name");
GGTOKEN;
E2←EXP;
IF (E2=NULL_RECORD) OR (!!EXPR:TYPE[E2]≠#SC)
THEN ERROR("Index of Array must be scalar");
FOR I←2 STEP 1 UNTIL ARRAYREC:#DIM[SYMBOL:OBJECT[PTR]] DO
BEGIN
IF TOKEN≠"," THEN ERROR("Need comma between fields of array index");
GTOKEN;
IF ((E3←EXP)=NULL_RECORD) OR (!!EXPR:TYPE[E3]≠#SC)
OR NOT CHECK_DIMENS(!!EXPR:DIMENS[E3],NIL_DIMENS)
THEN ERROR("Index of Array must be scalar");
!!EXPR:BRO[E3]←E2;
E2←E3;
END;
IF TOKEN≠"]" THEN ERROR("Need ] for bounds of array");
RETURN(E2);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE ARCODE(RPTR(SYMBOL)PTR; INTEGER OPERATION(XGTVAL));
BEGIN
RPTR(!!EXPR)E1;
IF (OPERATION≠XGTVAL) AND (OPERATION≠XCHNGE)
THEN ERROR("Error in ARCODE, OPERATION can take only XGTVAL or XCHNGE");
E1←!!EXPRM(2,OPERATION,SYMBOL:OFFSET[PTR]);
!!EXPR:TYPE[E1]←SYMBOL:TYPE[PTR];
!!EXPR:SON[E1]←ARNDXCODE(PTR);
!!EXPR:DIMENS[E1]←SYMBOL:DIMENS[PTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE SPRCODE(RPTR(SYMBOL)PRSYM);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPRM(2,XPROC,SYMBOL:OFFSET[PRSYM]);
!!EXPR:DIMENS[E1]←SYMBOL:OBJECT[PRSYM];
RETURN(E1);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE PRCODE(RPTR(SYMBOL)PRSYM);
BEGIN "prcode"
INTEGER NARGS; RPTR(PROC)P;
RPTR(!!EXPR)EF;
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[PRSYM]];
IF NARGS =0 THEN EF←SPRCODE(PRSYM)
ELSE BEGIN "procedure with arguments"
! E1,ETOP1 are pointers to the procedure call,
E0 refers to the arguments set up if they are values ;
RPTR(!!EXPR)E0,E1,ETOP1,ETMP,ETMP2; INTEGER I;
GGTOKEN;
IF TOKEN≠"(" THEN
BEGIN STRING S; INTEGER J; S←NULL;
IF (J←PROC:NON_DEFAULT_ARGS[P])>0
THEN ERROR("Need at least "&cvs(J)&" non-default parameters");
FOR J←1 STEP 1 UNTIL NARGS DO
S←S&","&PROC:DEFAULT_ARG[P][J];
$CLNSAVE←$CLNSAVE[1 TO ∞-LENGTH(TOKEN)];
S←"("&S[2 TO ∞]&")"&TOKEN;
ASKUSER(S);
GGTOKEN;
END;
ETOP1←E1←SPRCODE(PRSYM);
E0←NULL_RECORD;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "check each argument"
GGTOKEN;
IF PROC:ARGACCS[P][I] LAND #ARRTYP THEN
BEGIN "array argument found"
IF TOKENPTR=NULL_RECORD
THEN ERROR("Need array reference here")
ELSE IF SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
THEN ERROR("Need array reference here")
ELSE IF ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]
≠PROC:ARGDIM[P][I]
THEN ERROR("array dimensions dont agree with declaration")
ELSE IF NOT (SYMBOL:TYPE[TOKENPTR]=PROC:ARGTYPE[P][I]
OR (SYMBOL:TYPE[TOKENPTR]=#FR AND
PROC:ARGTYPE[P][I]=#TR)
OR (SYMBOL:TYPE[TOKENPTR]=#TR AND
PROC:ARGTYPE[P][I]=#FR))
THEN ERROR("array types are not the same as declared")
ELSE IF NOT CHECK_DIMENS(SYMBOL:DIMENS[TOKENPTR],
PROC:ARGDIMENS[P][I])
THEN WARN("incompatible array dimensions "
&DIMERR("formally decalared array "&
PROC:ARGNAME[P][I],PROC:ARGDIMENS[P][I],
"current array "&TOKEN,SYMBOL:DIMENS[TOKENPTR]));
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TOKENPTR]));
E1←ETMP;
END "array argument found"
ELSE BEGIN
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declaration");
IF NOT CHECK_DIMENS(!!EXPR:DIMENS[ETMP],PROC:ARGDIMENS[P][I])
THEN WARN("incompatible dimensions in substituting parameters"&
DIMERR("formal parameter "&PROC:ARGNAME[P][I],
PROC:ARGDIMENS[P][I],"current parameter ",
!!EXPR:DIMENS[ETMP]));
IF (PROC:ARGACCS[P][I]=0) OR
(PROC:ARGACCS[P][I] LAND #REFTYP) AND
(!!EXPR:OP[ETMP]≠XAGTVAL) AND
(!!EXPR:OP[ETMP]≠XGTVAL)
THEN
BEGIN "value"
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value"
ELSE BEGIN "reference"
IF !!EXPR:OP[ETMP]=XGTVAL THEN
BEGIN "xgtval"
ETMP2←NEW_EXPR(!!EXPR:X1[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
ETMP←!!EXPR:SON[ETMP];
##EL←##EL-2;
IF ETMP THEN
BEGIN
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END;
END "xgtval"
ELSE IF !!EXPR:OP[ETMP]=XAGTVAL
THEN
BEGIN "xagtval"
ETMP2←NEW_EXPR(!!EXPR:X2[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
##EL←##EL-1;
!!EXPR:OP[ETMP]←XPUSHINTI;
!!EXPR:#EL[ETMP]←2;
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END "xagtval"
ELSE ERROR("Disastrous error");
STOKEN←TRUE;
END "reference";
END;
GGTOKEN;
IF I<NARGS
THEN IF TOKEN=")" THEN
BEGIN STRING S; INTEGER J; S←NULL;
IF I<(J←PROC:NON_DEFAULT_ARGS[P])
THEN ERROR("Need at least "&cvs(J)&" non-default arguments");
FOR J←I+1 STEP 1 UNTIL NARGS DO
S←S&","&PROC:DEFAULT_ARG[P][J];
S←S[1 TO ∞]&")";
$CLNSAVE←$CLNSAVE[1 TO ∞-1];
ASKUSER(S);
GGTOKEN;
END
ELSE IF TOKEN≠"," THEN
BEGIN ERROR("Need comma between arguments");
GGTOKEN;
END;
IF I=NARGS AND TOKEN≠")" THEN
ERROR("Need right paren after argument list");
END "check each argument";
EF←NEW_EXPR(XNOOP,NEW_EXPR(XNOOP,E0,ETOP1));
END "procedure with arguments";
!!EXPR:TYPE[EF]←SYMBOL:TYPE[PRSYM];
!!EXPR:DIMENS[EF]←SYMBOL:DIMENS[PRSYM];
! newly inserted; GGTOKEN(FALSE); STOKEN←TRUE;
RETURN(EF);
END "prcode";
! checks that PRSYM points to a typed procedure ;
RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
IF SYMBOL:TYPE[PRSYM]=#PR
THEN IF RETURN_NULL THEN BEGIN STOKEN←TRUE; RETURN(NULL_RECORD); END
ELSE ERROR(SYMBOL:PNAME[PRSYM]&" cannot return a value and cannot be used here")
ELSE RETURN(PRCODE(PRSYM));
! strcode,vmcode,isaffixedcode,armreachcode;
RPTR(!!EXPR)PROCEDURE STRCODE(STRING S; INTEGER FIRSTNUM(XPUSHQI));
BEGIN
RPTR(!!EXPR)E;
INTEGER I;
IPUSH(FIRSTNUM); ! push string immediate pcode ;
IPUSH((LENGTH(S)+2)DIV 2); ! push number of words ;
DO IPUSH(LOP(S)+ (I←LOP(S)) LSH 8) UNTIL I=0;
E←NEW_RECORD(!!EXPR);
##EL←##EL+EXPR$:#BODY[!!EXPR:EXPR$[E]←βEXPR$];
!!EXPR:TYPE[E]←#ST;
RETURN(E);
END;
RPTR(!!EXPR)PROCEDURE VMCODE;
BEGIN "vmcode"
RPTR(!!EXPR)E,E1; INTEGER I,FUNNO,NARGS;
WORD_READ("("); FUNNO←INTEGER_READ;
WORD_READ(","); NARGS←INTEGER_READ;
E←!!EXPRM(3,XVM,FUNNO,NARGS);
!!EXPR:TYPE[E]←#SC;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "first the value arguments"
INTEGER TYPECODE;
WORD_READ(",");
TYPECODE←INTEGER_READ;
WORD_READ(",");
GGTOKEN;
CASE TYPECODE OF
BEGIN
[0][2] IF #TOKEN=INT_TYPE OR #TOKEN=REAL_TYPE THEN
BEGIN INTEGER J; REAL R; INTEGER I1,I2;
RPTR(!!EXPR)E2;
R←REALSCAN(TOKEN,J); FLTOUT(R,I1,I2);
E2←!!EXPRM(2,I1,I2);
E1←!!EXPRM(2,TYPECODE,2);
!!EXPR:BRO[E1]←E2;
END
ELSE IF #TOKEN=ID_TYPE THEN
BEGIN IF SYMBOL:OFFSET[TOKENPTR]>'777 AND
SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:TYPE[TOKENPTR]=#SC
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need simple scalar id type here");
END
ELSE ERROR("Need scalar variable or constant here");
[4] IF TOKEN=dquote THEN
BEGIN STRING T; RPTR(!!EXPR) E2;
T←READTILL(dquote);
E2←STRCODE(T,TYPECODE);
E1←NEW_RECORD(!!EXPR);
!!EXPR:BRO[E1]←E2;
END
ELSE IF #TOKEN=ID_TYPE AND SYMBOL:TYPE[TOKENPTR]=#ST
AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need string constant or variabl here");
[6] IF #TOKEN=ID_TYPE AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(3,TYPECODE,0,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("only simple variable allowed here");
ELSE ERROR("Only 0,2,4,6 now valid here")
END;
!!EXPR:SON[E1]←E;
E←E1;
END "first the value arguments";
WORD_READ(",");
NARGS←INTEGER_READ; ! now the reference arguments ;
E1←!!EXPRM(1,NARGS);
!!EXPR:SON[E1]←E;
E←E1;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN INTEGER ARGTYP;
WORD_READ(",");
ARGTYP←INTEGER_READ;
WORD_READ(",");
GTOKEN;
IF #TOKEN=ID_TYPE AND SYMBOL:ACCESS[TOKENPTR]=#SIMPLE
AND SYMBOL:OFFSET[TOKENPTR]>'777
THEN E1←!!EXPRM(2,ARGTYP,SYMBOL:OFFSET[TOKENPTR])
ELSE ERROR("Need a local variable here");
!!EXPR:SON[E1]←E;
E←E1;
END;
WORD_READ(")");
GGTOKEN(FALSE);
!!EXPR:TYPE[E]←#SC;
RETURN(E);
END "vmcode";
RPTR(!!EXPR) PROCEDURE ISAFFIXEDCODE;
BEGIN
RPTR(!!EXPR)E,!E1,!E2; RPTR(EXPR$)E1,E2;
WORD_READ("(");GGTOKEN; STOKEN←TRUE;
IF #TOKEN=ID_TYPE
THEN IF SYMBOL:ACCESS[TOKENPTR] =#SIMPLE THEN E1←IDREF(TOKENPTR)
ELSE IF SYMBOL:ACCESS[TOKENPTR]=#ARRAY THEN E1←AREF(TOKENPTR,XGTVAL)
ELSE ERROR("Need a frame variable here");
WORD_READ(","); GGTOKEN; STOKEN←TRUE;
IF #TOKEN=ID_TYPE
THEN IF SYMBOL:ACCESS[TOKENPTR] =#SIMPLE THEN E2←IDREF(TOKENPTR)
ELSE IF SYMBOL:ACCESS[TOKENPTR]=#ARRAY THEN E2←AREF(TOKENPTR,XGTVAL)
ELSE ERROR("Need a frame variable here");
WORD_READ(")");
!E2←NEW_RECORD(!!EXPR);
!!EXPR:EXPR$[!E2]←E2;
!E1←NEW_RECORD(!!EXPR);
!!EXPR:EXPR$[!E1]←E1;
!!EXPR:BRO[!E1]←!E2;
E←NEW_EXPR(XISAFFIXED,!E1);
!!EXPR:TYPE[E]←#SC;
##EL←##EL+EXPR$:#BODY[E1]+EXPR$:#BODY[E2];
GGTOKEN(FALSE);
RETURN(E);
END;
RPTR(!!EXPR) PROCEDURE ARMREACHCODE;
BEGIN
RPTR(!!EXPR)E,E1,E2; RPTR(EXPR$)EE1;
WORD_READ("(");GGTOKEN; STOKEN←TRUE;
IF NOT(EQU(TOKEN,"BARM") OR EQU(TOKEN,"YARM") OR EQU(TOKEN,"GARM")
OR EQU(TOKEN,"RARM")) THEN ERROR("Need an arm here");
EE1←IDREF(TOKENPTR);
WORD_READ(",");GGTOKEN;
E2←EXP;
!!EXPR:BRO[E1←NEW_RECORD(!!EXPR)]←E2;
!!EXPR:EXPR$[E1]←EE1; STOKEN←TRUE;
WORD_READ(")");GGTOKEN(FALSE);
E←NEW_EXPR(XARMREACH,E1);
!!EXPR:TYPE[E]←#SC;
##EL←##EL+EXPR$:#BODY[EE1];
RETURN(E);
END;
! mkexpr,gtexpr,aref,idref,pref;
RPTR(EXPR$) PROCEDURE MKEXPR(INTEGER BUFSIZ;RPTR(!!EXPR)EE);
IF BUFSIZ=0 THEN RETURN(NULL_RECORD) ELSE
BEGIN "MKEXPR"
! routine for changing the tree structure form of the expression into
an integer array.
The integer array is returned in EXPR$:BODY;
! Caution : the bro field of the expression EE should be null ;
INTEGER ARRAY BUFFER[1:BUFSIZ]; INTEGER Q; RPTR(EXPR$) $$;
PROCEDURE PUSHBUFFER(INTEGER I);
BUFFER[Q←Q+1]←I;
PROCEDURE PUSHARRAY(RPTR(EXPR$)EPTR);
IF EPTR THEN BEGIN
ARRBLT(BUFFER[Q+1],EXPR$:BODY[EPTR][1],EXPR$:#BODY[EPTR]);
Q←Q+EXPR$:#BODY[EPTR]; END;
RECURSIVE PROCEDURE REDUCE(RPTR(!!EXPR)E);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPR:SON[E];
WHILE E1≠NULL_RECORD DO
BEGIN REDUCE(E1);
E1←!!EXPR:BRO[E1];
END;
PUSHARRAY(!!EXPR:EXPR$[E]);
IF !!EXPR:#EL[E]=0 THEN RETURN;
PUSHBUFFER(!!EXPR:OP[E]);
IF !!EXPR:#EL[E]=1 THEN RETURN;
PUSHBUFFER(!!EXPR:X1[E]);
IF !!EXPR:#EL[E]=2 THEN RETURN;
PUSHBUFFER(!!EXPR:X2[E]);
END;
Q←0;
REDUCE(EE);
IF Q≠BUFSIZ THEN ERROR("something is wrong, the string of numbers"&CVS(Q)&" not equal to expected"&CVS(BUFSIZ));
RETURN_NULL←FALSE;
$$←αEXPR$(BUFFER,!!EXPR:TYPE[EE]);
EXPR$:DIMENS[$$]←!!EXPR:DIMENS[EE];
RETURN($$);
END "MKEXPR";
RPTR(EXPR$)RECURSIVE PROCEDURE GTEXPR;
BEGIN "GTEXPR"
! driver for MKEXPR;
RPTR(!!EXPR)EE;
INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL;
##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
RETURN(MKEXPR(#EL,EE));
END "GTEXPR";
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE AREF(RPTR(SYMBOL)S;INTEGER OPERATION);
BEGIN "AREF"
RPTR(!!EXPR)EE; INTEGER #EL,##ELSAVE;
##ELSAVE←##EL;
##EL←0;
EE←ARCODE(S,OPERATION);
#EL←##EL;
##EL←##ELSAVE;
RETURN(MKEXPR(#EL,EE));
END "AREF";
INTERNAL RPTR(EXPR$)PROCEDURE PREF(RPTR(SYMBOL)S);
BEGIN
RPTR(!!EXPR)EE;
##EL←0;
EE←PRCODE(S);
RETURN(MKEXPR(##EL,EE));
END;
! produces the EXPR$ record for references to variables
i.e. code to push the desired offset onto the stack ;
INTERNAL RECURSIVE RPTR(EXPR$)PROCEDURE IDREF(REFERENCE RPTR(SYMBOL)S);
BEGIN "IDREF" INTEGER #EL,##ELSAVE;
RPTR(!!EXPR)EE;
GGTOKEN;
IF TOKENPTR=NULL_RECORD THEN ERROR("Need identifier here")
ELSE S←TOKENPTR;
##ELSAVE←##EL;
##EL←0;
EE←EXP;
IF !!EXPR:OP[EE]=XGTVAL THEN !!EXPR:OP[EE]←XPUSHOFFSET
ELSE IF !!EXPR:OP[EE]=XAGTVAL THEN !!EXPR:OP[EE]←XAPUSHOFFSET
ELSE ERROR("Need an identifier or array element here");
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
RETURN(MKEXPR(#EL,EE));
END "IDREF";
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:200];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
INTERNAL SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
INTERNAL SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
INTERNAL PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
INTERNAL PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off;
INTERNAL RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
EE←MK_EXPR$;
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTERNAL INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
BEGIN RPTR(EXPR$)E;
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
E←$APPEND(EXPR$G(S),EXPR$1(XRTVAL),SYMBOL:TYPE[S])
ELSE
IF SYMBOL:INDEX[S]>0
THEN E←$APPEND(EXPR$2(XARTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S])
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN E←$APPEND(EXPR$2(XGTVAL,SYMBOL:OFFSET[S]),
EXPR$1(XRTVAL),SYMBOL:TYPE[S])
ELSE E←EXPR$1(XNOOP);
EXPR$:DIMENS[E]←SYMBOL:DIMENS[S];
RETURN(E);
END;
INTERNAL RPTR(EXPR$) PROCEDURE EXPR$G(RPTR(SYMBOL)S);
BEGIN RPTR(EXPR$)E;
IF SYMBOL:ACCESS[S]=#ARRAY_ELEMENT THEN
BEGIN
STRING S1; INTEGER I;
INTEGER ARRAY INDEX[1:5]; INTEGER IX;
S1←SYMBOL:PNAME[S];
DO I←LOP(S1) UNTIL I="[";
IX←0;
DO INDEX[IX←IX+1]←INTSCAN(S1,I) UNTIL I="]";
FOR I←IX STEP -1 UNTIL 1 DO BEGIN IPUSH(XPUSHINTI); IPUSH(INDEX[I]); END;
FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
E←βEXPR$(SYMBOL:TYPE[S]);
END ELSE
IF SYMBOL:INDEX[S]>0
THEN E←$APPEND(EXPR$2(XAGTVAL,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S])
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN E←$APPEND(EXPR$1(XGTVAL),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S])
ELSE E←EXPR$1(XNOOP);
EXPR$:DIMENS[E]←SYMBOL:DIMENS[S];
RETURN(E);
END;
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE(0));
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
EE←MK_EXPR$;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$ID(RPTR(SYMBOL)S);
BEGIN RPTR(EXPR$)E;
IF SYMBOL:ACCESS[S]≠#SIMPLE THEN ERROR("EXPR$ID must take simple argument")
ELSE IF SYMBOL:INDEX[S]>0 THEN
E←$APPEND(EXPR$2(XAPUSHOFFSET,SYMBOL:INDEX[S]),
EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S])
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN E←$APPEND(EXPR$1(XPUSHINTI),EXPR$1(SYMBOL:OFFSET[S]),SYMBOL:TYPE[S])
ELSE E←EXPR$1(XNOOP);
EXPR$:DIMENS[E]←SYMBOL:DIMENS[S];
RETURN(E);
END;
! $append,$aappend;
INTERNAL RPTR(EXPR$) PROCEDURE $APPEND(RPTR(EXPR$)E1,E2; INTEGER TYPE(0));
BEGIN
RPTR(EXPR$)ARRAY TEMP[1:2];
TEMP[1]←E1;TEMP[2]←E2;
RETURN($AAPPEND(TEMP,TYPE));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AAPPEND(RPTR(EXPR$) ARRAY APTR;INTEGER TYPE(0));
BEGIN RPTR(EXPR$) PTR;
INTEGER LA,UA; LA←ARRINFO(APTR,1); UA←ARRINFO(APTR,2);
BEGIN INTEGER I,BSIZE,DSIZE; INTEGER ARRAY ASIZE,TSIZE[LA:UA];
RPTR(DBEXPR)ARRAY DPTR[LA:UA];
BSIZE←DSIZE←0;
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN BSIZE←BSIZE + (ASIZE[I]←EXPR$:#BODY[APTR[I]]);
IF BSIZE THEN
BEGIN "B"
INTEGER ARRAY BUFF[1:BSIZE]; INTEGER J1;
PTR←MK_EXPR$;J1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF ASIZE[I]>0 THEN
BEGIN ARRBLT(BUFF[J1],EXPR$:BODY[APTR[I]][1],ASIZE[I]);
J1←J1+ASIZE[I];END;
MEMORY[LOCATION(BUFF)] ↔ MEMORY[LOCATION(EXPR$:BODY[PTR])];
EXPR$:#BODY[PTR]←BSIZE;
IF !DEBUG AND ¬!!DEBUGGING
THEN BEGIN
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN DSIZE←DSIZE + (TSIZE[I]←
DBEXPR:#COORD[(DPTR[I]←EXPR$:DBEXPR[APTR[I]])]);
IF DSIZE
THEN BEGIN "D"
INTEGER ARRAY TXTPOS,COORD[1:DSIZE];INTEGER J2;
RPTR(BLOCKREC)ARRAY BLOCK[1:DSIZE];RPTR(DBEXPR)DBR;
DBR←EXPR$:DBEXPR[PTR];J2←1;
FOR I←LA STEP 1 UNTIL UA DO
IF TSIZE[I]>0 THEN BEGIN
ARRBLT(TXTPOS[J2],DBEXPR:TXTPOS[DPTR[I]][1],TSIZE[I]);
ARRBLT(COORD[J2],DBEXPR:COORD[DPTR[I]][1],TSIZE[I]);
ARRBLT(BLOCK[J2],DBEXPR:BLOCK[DPTR[I]][1],TSIZE[I]);
J2←J2+TSIZE[I];
END;
MEMORY[LOCATION(TXTPOS)] ↔ MEMORY[LOCATION(DBEXPR:TXTPOS[DBR])];
MEMORY[LOCATION(COORD)] ↔ MEMORY[LOCATION(DBEXPR:COORD[DBR])];
MEMORY[LOCATION(BLOCK)] ↔ MEMORY[LOCATION(DBEXPR:BLOCK[DBR])];
DBEXPR:#COORD[DBR]←DSIZE;
END "D";
END;
END "B"
ELSE RETURN(NULL_RECORD);
END;
EXPR$:TYPE[PTR]←TYPE;
RETURN(PTR);
END;
! $$gtidref,$$gtanyexp,$$gtexpr,$$gtvexpr;
! returns code to push offset of id on stack - type must
be the same, else does not return, unless type=0 ;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTIDREF(INTEGER TYPE;
REFERENCE RPTR(SYMBOL)SYM; STRING S);
BEGIN RPTR(EXPR$)E;
E←IDREF(SYM);
IF (TYPE=0) OR (EXPR$:TYPE[E]=TYPE) OR
(TYPE=#FR AND EXPR$:TYPE[E]=#TR) OR
(TYPE=#TR AND EXPR$:TYPE[E]=#FR)
THEN RETURN(E)
ELSE ERROR("Id type found does not agree with expected type in "&S);
END;
! returns an expr of indicated type or doesnt return at all;
INTERNAL RPTR(EXPR$) PROCEDURE $$GTANYEXP(STRING S;INTEGER TYPE);
BEGIN
RPTR(EXPR$)E; INTEGER TYPEF;
TYPEF←EXPR$:TYPE[E←$$GTEXPR];
IF (TYPEF=TYPE) OR (TYPEF=#TR AND TYPE=#FR) OR (TYPEF=#FR AND TYPE=#TR)
THEN RETURN(E)
ELSE IF TYPE≤#RT THEN ERROR("Need "&DTYPES[TYPE]&" expression for "&S)
ELSE ERROR("Need TRANS or FRAME expression for "&S);
END;
INTERNAL REAL PROCEDURE $GTREAL(STRING S);
BEGIN "$GTREAL"
RPTR(!!EXPR)EE; INTEGER ##ELSAVE,#EL;
##ELSAVE←##EL; ##EL←0;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
#EL←##EL;
##EL←##ELSAVE;
IF !!EXPR:CONST[EE] THEN RETURN(!!EXPR:RLVAL[EE]) ELSE
ERROR("Need real value for "&S);
END "$GTREAL";
INTERNAL RPTR(EXPR$) RECURSIVE PROCEDURE $$GTEXPR;
RETURN(GTEXPR);
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $$GTVEXPR;
RETURN($ELFEVAL(GTEXPR));
! $$gtxp2;
INTERNAL RPTR(EXPR$)PROCEDURE $$GTXP2;
BEGIN
RPTR(EXPR$)E;
RETURN_NULL←TRUE;
E←GTEXPR;
RETURN_NULL←FALSE;
RETURN(E);
END;
END "EXPR";